Linux Cubed Series 7: Sunsite/Linux Cubed Series 7 - Sunsite Vol 1.iso/system/shells/scsh-0.4/scsh-0/scsh-0.4.2/bcomp/syntax.scm

Text File | 1995-10-13 | 24KB | 826 lines

; Copyright (c) 1993, 1994 Richard Kelsey and Jonathan Rees.  See file COPYING.

; Syntactic stuff: transforms and operators.


(define usual-operator-type
  (procedure-type any-arguments-type value-type #f))

; --------------------
; Operators (= special operators and primitives)

(define-record-type operator :operator
  (make-operator type nargs uid name)
  operator?
  (type operator-type set-operator-type!)
  (nargs operator-nargs)
  (uid operator-uid)
  (name operator-name))

(define-record-discloser :operator
  (lambda (s)
    (list 'operator
      (operator-name s)
      (type->sexp (operator-type s) #t))))

(define (get-operator name . type-option)
  (let ((type (if (null? type-option) #f (car type-option)))
    (probe (table-ref operators-table name)))
    (if (operator? probe)
    (let ((previous-type (operator-type probe)))
      (cond ((not type))
        ((symbol? type)        ; 'leaf or 'internal
         (if (not (eq? type previous-type))
             (warn "operator type inconsistency" name type previous-type)))
        ((subtype? type previous-type)  ;Improvement
         (set-operator-type! probe type))
        ((not (subtype? previous-type type))
         (warn "operator type inconsistency"
               name
               (type->sexp previous-type 'foo)
               (type->sexp type 'foo))))
      probe)
    (let* ((uid *operator-uid*)
           (type (or type usual-operator-type))
           (op (make-operator type
                  (if (and (not (symbol? type))
                       (fixed-arity-procedure-type? type))
                      (procedure-type-arity type)
                      #f)
                  uid
                  name)))
      (if (>= uid number-of-operators)
          (warn "too many operators" (operator-name op) (operator-type op)))
      (set! *operator-uid* (+ *operator-uid* 1))
      (table-set! operators-table (operator-name op) op)
      (vector-set! the-operators uid op)
      op))))

(define *operator-uid* 0)

(define operators-table (make-table))

(define number-of-operators 200)  ;Fixed-size limits bad, but speed good
(define the-operators (make-vector number-of-operators #f))

; --------------------
; Operator tables (for fast dispatch)

(define (make-operator-table default . mumble-option)
  (let ((v (make-vector number-of-operators default)))
    (if (not (null? mumble-option))
    (define-usual-suspects v (car mumble-option)))
    v))

(define operator-table-ref vector-ref)

(define (operator-lookup table op)
  (operator-table-ref table (operator-uid op)))

(define (operator-define! table name proc-or-type . proc-option)
  (if (null? proc-option)
      (vector-set! table        ;Obsolescent
           (operator-uid (if (pair? name)
                     (get-operator (car name) (cadr name))
                     (get-operator name)))
           proc-or-type)
      (vector-set! table
           (operator-uid (get-operator name proc-or-type))
           (car proc-option))))

; --------------------
; Nodes

; A node is an annotated expression (or definition or other form).
; The FORM component of a node is an S-expression of the same form as
; the S-expression representation of the expression.  E.g. for
; literals, the form is the literal value; for variables the form is
; the variable name; for IF expressions the form is a 4-element list
; (ignored test con alt).  Nodes also have a tag identifying what kind
; of node it is (literal, variable, if, etc.) and a property list.

(define-record-type node :node
  (really-make-node uid form plist)
  node?
  (uid node-operator-id)
  (form node-form)
  (plist node-plist set-node-plist!))

(define-record-discloser :node
  (lambda (n) (list (operator-name (node-operator n)) (node-form n))))

(define (make-node operator form)
  (really-make-node (operator-uid operator) form '()))

(define (node-ref node key)
  (let ((probe (assq key (node-plist node))))
    (if probe (cdr probe) #f)))

(define (node-set! node key value) ;gross
  (if value
      (let ((probe (assq key (node-plist node))))
    (if probe
        (set-cdr! probe value)
        (set-node-plist! node (cons (cons key value) (node-plist node)))))
      (let loop ((l (node-plist node)) (prev #f))
    (cond ((null? l) 'lose)
          ((eq? key (caar l))
           (if prev
           (set-cdr! prev (cdr l))
           (set-node-plist! node (cdr l))))
          (else (loop (cdr l) l))))))

(define (node-operator node)
  (vector-ref the-operators (node-operator-id node)))


(define (node-predicate name . type-option)
  (let ((id (operator-uid (apply get-operator name type-option))))
    (lambda (node)
      (= (node-operator-id node) id))))

(define (make-similar-node node form)
  (if (equal? form (node-form node))
      node
      (make-node (node-operator node) form)))

; --------------------
; Generated names

; Generated names make lexically-scoped macros work.  They're the same
; as what Alan Bawden and Chris Hanson call "aliases".  The parent
; field is always another name (perhaps generated).  The parent chain
; provides an access path to the name's binding, should one ever be
; needed.  That is: If name M is bound to a transform T that generates
; name G as an alias for name N, then M is (generated-parent-name G),
; so we can get the binding of G by accessing the binding of N in T's
; environment of closure, and we get T by looking up M in the
; environment in which M is *used*.

(define-record-type generated :generated
  (make-generated symbol token env parent-name)
  generated?
  (symbol      generated-symbol)
  (token       generated-token)
  (env           generated-env)
  (parent-name generated-parent-name))

(define-record-discloser :generated
  (lambda (name)
    (list 'generated (generated-symbol name) (generated-uid name))))

(define (generate-name symbol env parent-name)    ;for opt/inline.scm
  (make-generated symbol (cons #f #f) env parent-name)) ;foo

(define (generated-uid g)
  (let ((t (generated-token g)))
    (or (car t)
    (let ((uid *generated-uid*))
      (set! *generated-uid* (+ *generated-uid* 1))
      (set-car! t uid)
      uid))))

(define *generated-uid* 0)

(define (name->symbol name)
  (if (symbol? name)
      name
      (string->symbol (string-append (symbol->string (generated-symbol name))
                     "##"
                     (number->string (generated-uid name))))))

(define (name-hash name)
  (cond ((symbol? name)
     (string-hash (symbol->string name)))
    ((generated? name)
     (name-hash (generated-symbol name)))
    (else (error "invalid name" name))))


; Used by QUOTE to turn generated names back into symbols

(define (desyntaxify thing)
  (cond ((or (boolean? thing) (null? thing) (number? thing)
         (symbol? thing) (char? thing))
     thing)
    ((string? thing)
     (make-immutable! thing))
    ((generated? thing) (desyntaxify (generated-symbol thing)))
    ((pair? thing)
     (make-immutable!
      (let ((x (desyntaxify (car thing)))
        (y (desyntaxify (cdr thing))))
        (if (and (eq? x (car thing))
             (eq? y (cdr thing)))
        thing
        (cons x y)))))
    ((vector? thing)
     (make-immutable!
      (let ((new (make-vector (vector-length thing) #f)))
        (let loop ((i 0) (same? #t))
          (if (>= i (vector-length thing))
          (if same? thing new)
          (let ((x (desyntaxify (vector-ref thing i))))
            (vector-set! new i x)
            (loop (+ i 1)
              (and same? (eq? x (vector-ref thing i))))))))))
    ((operator? thing)
     (warn "operator in quotation" thing)
     (operator-name thing))  ;Foo
    (else
     (warn "invalid datum in quotation" thing)
     thing)))

; --------------------
; Transforms

; A transform represents a source-to-source rewrite rule: either a
; macro or an in-line procedure.

(define-record-type transform :transform
  (really-make-transform xformer env type aux-names source id)
  transform?
  (xformer   transform-procedure)
  (env         transform-env)
  (type         transform-type)
  (aux-names transform-aux-names)
  (source    transform-source)    ;for reification
  (id         transform-id))

(define (make-transform thing env type source id)
  (let ((type (if (or (pair? type) (symbol? type))
          (sexp->type type #t)
          type)))
    (make-immutable!
     (if (pair? thing)
     (really-make-transform (car thing) env type (cdr thing) source id)
     (really-make-transform thing env type #f source id)))))

(define-record-discloser :transform
  (lambda (m) (list 'transform (transform-id m))))

(define (maybe-transform t exp env-of-use)
  (let* ((token (cons #f #f))
     (new-env (bind-aliases token t env-of-use))
     (rename (make-name-generator (transform-env t)
                      token
                      (node-form (car exp))))
     (compare
      (lambda (name1 name2)
        (or (eqv? name1 name2)
        (and (name? name1)
             (name? name2)
             (same-denotation? (lookup new-env name1)
                       (lookup new-env name2)))))))
    (values ((transform-procedure t) exp rename compare)
        new-env
        token)))

(define (bind-aliases token t env-of-use)
  (let ((env-of-definition (transform-env t)))
    (if (procedure? env-of-definition)
    (lambda (name)
      (if (and (generated? name)
           (eq? (generated-token name) token))
          (lookup env-of-definition (generated-symbol name))
          (lookup env-of-use name)))
    env-of-use)))  ;Lose

(define (make-name-generator env token parent-name)
  (let ((alist '()))            ;list of (symbol . generated)
    (lambda (symbol)
      (if (symbol? symbol)
      (let ((probe (assq symbol alist)))
        (if probe
        (cdr probe)
        (let ((new-name (make-generated symbol token env parent-name)))
          (set! alist (cons (cons symbol new-name)
                    alist))
          new-name)))
      (error "non-symbol argument to rename procedure"
         symbol parent-name)))))

(define (same-denotation? x y)
  (or (equal? x y)
      (and (binding? x)
       (binding? y)
       (eq? (binding-place x) (binding-place y)))))


; --------------------
; Bindings: the things that are usually returned by LOOKUP.

; Representation is #(type place operator-or-transform-or-#f).
; For top-level bindings, place is usually a location.

(define binding? vector?)
(define (binding-type b) (vector-ref b 0))
(define (binding-place b) (vector-ref b 1))
(define (binding-static b) (vector-ref b 2))

(define (set-binding-place! b place) (vector-set! b 1 place))

(define (make-binding type place static)
  (let ((b (make-vector 3 place)))
    (vector-set! b 0 type)
    (vector-set! b 2 static)
    b))

(define (clobber-binding! b type place static)
  (vector-set! b 0 type)
  (if place
      (set-binding-place! b place))
  (vector-set! b 2 static))

; Return a binding that's similar to the given one, but has its type
; replaced with the given type.

(define (impose-type type b integrate?)
  (if (or (eq? type syntax-type)
      (not (binding? b)))
      b
      (make-binding (if (eq? type undeclared-type)
            (let ((type (binding-type b)))
              (if (variable-type? type)
                  (variable-value-type type)
                  type))
            type)
            (binding-place b)
            (if integrate?
            (binding-static b)
            #f))))

; Return a binding that's similar to the given one, but has any
; procedure integration or other unnecesary static information
; removed.  But don't remove static information for macros (or
; structures, interfaces, etc.)

(define (forget-integration b)
  (if (and (binding-static b)
       (subtype? (binding-type b) any-values-type))
      (make-binding (binding-type b)
            (binding-place b)
            #f)
      b))

; --------------------
; Expression classifier.  Returns a node.

(define (classify form env)
  (cond ((node? form)
     (if (and (name-node? form)
          (not (node-ref form 'binding)))
         (classify-name (node-form form) env)
         form))
    ((name? form)
     (classify-name form env))
        ((pair? form)
     (let ((op-node (classify (car form) env)))
       (if (name-node? op-node)
           (let ((probe (node-ref op-node 'binding)))
         (if (binding? probe)
             (let ((s (binding-static probe)))
               (cond ((operator? s)
                  (classify-operator-form s op-node form env))
                 ((and (transform? s)
                   (eq? (binding-type probe) syntax-type))
                  ;; Non-syntax transforms (i.e. procedure
                  ;; integrations) get done by MAYBE-TRANSFORM-CALL.
                  (classify-macro-application
                           s (cons op-node (cdr form)) env))
                 (else
                  (classify-call op-node form env))))
             (classify-call op-node form env)))
           (classify-call op-node form env))))
    ((literal? form)
     (classify-literal form))
    ;; ((qualified? form) ...)
    (else
     (classify (syntax-error "invalid expression" form) env))))

(define call-node? (node-predicate 'call 'internal))
(define name-node? (node-predicate 'name 'leaf))

(define classify-literal
  (let ((op (get-operator 'literal 'leaf)))
    (lambda (exp)
      (make-node op exp))))

(define classify-call
  (let ((operator/call (get-operator 'call 'internal)))
    (lambda (proc-node exp env)
      (make-node operator/call
         (if (eq? proc-node (car exp))
             exp        ;+++
             (cons proc-node (cdr exp)))))))

; An environment is a procedure that takes a name and returns one of
; the following:
;
;  1. A binding record.
;  2. A node, which is taken to be a substitution for the name.
;  3. Another name, meaning that the first name is unbound.  The name
;     returned will be a symbol even if the original name was generated.
;
; In case 1, CLASSIFY caches the binding as the node's BINDING property.
; In case 2, it simply returns the node.

(define (classify-name name env)
  (let ((binding (lookup env name)))
    (if (node? binding)
    binding
    (let ((node (make-node operator/name name)))
      (if (not (unbound? binding))
          (node-set! node 'binding binding))
      node))))

(define operator/name (get-operator 'name 'leaf))

; Expand a macro or in-line procedure application.

(define (classify-macro-application t form env-of-use)
  (classify-transform-application
       t form env-of-use
       (lambda ()
     (classify (syntax-error "use of macro doesn't match definition"
                 (cons (schemify (car form) env-of-use)
                       (desyntaxify (cdr form))))
           env-of-use))))


(define classify-transform-application
  (let ((operator/with-aliases (get-operator 'with-aliases syntax-type)))
    (lambda (t form env-of-use lose)
      (call-with-values (lambda () (maybe-transform t form env-of-use))
    (lambda (new-form new-env token)
      (cond ((eq? new-form form)
         (lose))
        ((eq? new-env env-of-use)
         (classify new-form new-env))
        (else
         (make-node operator/with-aliases
                `(with-aliases ,(car form)
                       ,token
                       ,new-form)))))))))

(define (maybe-transform-call proc-node node env)
  (if (name-node? proc-node)
      (let ((b (or (node-ref proc-node 'binding)
           (lookup env (node-form proc-node)))))
    (if (binding? b)
        (let ((s (binding-static b)))
          (cond ((transform? s)
             (classify-transform-application s
                             (node-form node)
                             env
                             (lambda () node)))
            ;; ((operator? s) (make-node s (node-form node)))
            (else node)))
        node))
      node))


; --------------------
; Specialist classifiers for particular operators

(define (classify-operator-form op op-node form env)
  ((operator-table-ref classifiers (operator-uid op))
   op op-node form env))

(define classifiers
  (make-operator-table (lambda (op op-node form env)
             (if (let ((nargs (operator-nargs op)))
                   (or (not nargs)
                   (= nargs (length (cdr form)))))
                 (make-node op (cons op-node (cdr form)))
                 (classify-call op-node form env)))))

(define (define-classifier name proc)
  (operator-define! classifiers name syntax-type proc))

; Remove generated names from quotations.

(define-classifier 'quote
  (lambda (op op-node exp env)
    (make-node op (list op-node (desyntaxify (cadr exp))))))

; Convert one-armed IF to two-armed IF.

(define-classifier 'if
  (lambda (op op-node exp env)
    (make-node op
           (cons op-node
             (if (null? (cdddr exp))
             (append (cdr exp) (list (unspecific-node)))
             (cdr exp))))))

(define unspecific-node
  (let ((op (get-operator 'unspecific
              (proc () unspecific-type))))
    (lambda ()
      (make-node op '(unspecific)))))

; Rewrite (define (name . vars) body ...)
;  as (define foo (lambda vars body ...)).

(define-classifier 'define
  (let ((operator/lambda (get-operator 'lambda syntax-type))
    (operator/unassigned (get-operator 'unassigned
                       (proc () value-type)))) ;foo
    (lambda (op op-node form env)
      (let ((pat (cadr form)))
    (make-node op
           (cons op-node
             (if (pair? pat)
                 (list (car pat)
                   (make-node operator/lambda
                          `(lambda ,(cdr pat)
                         ,@(cddr form))))
                 (list pat
                   (if (null? (cddr form))
                       (make-node operator/unassigned
                          `(unassigned))
                       (caddr form))))))))))

;(define (make-define-node op op-node lhs rhs)
;  (make-node op (list op-node lhs rhs)))

(define define-node? (node-predicate 'define))
(define define-syntax-node? (node-predicate 'define-syntax syntax-type))


; For the module system:

(define-classifier 'structure-ref
  (lambda (op op-node form env)
    (let ((struct-node (classify (cadr form) env))
      (lose (lambda ()
          (classify (syntax-error "invalid structure reference" form)
                env))))
      (if (and (name? (caddr form))
           (name-node? struct-node))
      (let ((b (node-ref struct-node 'binding)))
        (if (and (binding? b) (binding-static b)) ; (structure? ...)
        (classify (generate-name (desyntaxify (caddr form))
                     (binding-static b)
                     (node-form struct-node))
              env)
        (lose)))
      (lose)))))

; Magical Scheme 48 internal thing, mainly for use by the
; DEFINE-PACKAGE macro.

(define-classifier '%file-name%
  (let ((operator/quote (get-operator 'quote syntax-type)))
    (lambda (op op-node form env)
      (make-node operator/quote `',(get-funny env funny-name/source-file-name)))))

(define funny-name/source-file-name
  (string->symbol ".source-file-name."))

(define (bind-source-file-name filename env)
  (if filename
      (bind1 funny-name/source-file-name
         (make-binding syntax-type #f filename)
         env)
      env))


; To do:
;  Check syntax of others special forms

; --------------------
; Environments

(define (lookup env name)
  (env name))

(define (bind1 name binding env)
  (lambda (a-name)
    (if (eq? a-name name)
    binding
    (lookup env a-name))))

; corollary

(define (bind names bindings env)
  (cond ((null? names) env)
    (else
     (bind1 (car names)
        (car bindings)
        (bind (cdr names) (cdr bindings) env)))))

(define (bindrec names env->bindings env)
  (set! env (bind names
          (env->bindings (lambda (a-name) (env a-name)))
          env))
  env)


; --------------------
; Utilities

(define (literal? exp)
  (or (number? exp) (char? exp) (string? exp) (boolean? exp)))

(define (number-of-required-args formals)
  (do ((l formals (cdr l))
       (i 0 (+ i 1)))
      ((not (pair? l)) i)))

(define (n-ary? formals)
  (cond ((null? formals) #f)
    ((pair? formals) (n-ary? (cdr formals)))
    (else #t)))

(define (normalize-formals formals)
  (cond ((null? formals) '())
        ((pair? formals)
     (cons (car formals) (normalize-formals (cdr formals))))
        (else (list formals))))


(define (syntax? d)
  (cond ((operator? d)
     (eq? (operator-type d) syntax-type))
    ((transform? d)
     (eq? (transform-type d) syntax-type))
    (else #f)))

(define (name? thing)
  (or (symbol? thing)
      (generated? thing)))

(define unbound? name?)


; --------------------
; LET-SYNTAX and friends

(define (define-usual-suspects table mumble)

  (operator-define! table 'let-syntax syntax-type
    (mumble (lambda (node env)
          (let* ((form (node-form node))
             (specs (cadr form)))
        (values (caddr form)
            (bind (map car specs)
                  (map (lambda (spec)
                     (make-binding syntax-type
                           (list 'let-syntax)
                           (process-syntax (cadr spec)
                                   env
                                   (car spec)
                                   env)))
                   specs)
                  env))))))

  (operator-define! table 'letrec-syntax syntax-type
    (mumble (lambda (node env)
          (let* ((form (node-form node))
             (specs (cadr form)))
        (values (caddr form)
            (bindrec (map car specs)
                 (lambda (new-env)
                   (map (lambda (spec)
                      (make-binding
                         syntax-type
                         (list 'letrec-syntax)
                         (process-syntax (cadr spec)
                                 new-env
                                 (car spec)
                                 new-env)))
                    specs))
                 env))))))

  (operator-define! table 'with-aliases syntax-type
    (mumble (lambda (node env)
          (let ((form (node-form node)))
        (values (cadddr form)
            (bind-aliases (caddr form)
                      (binding-static
                           (node-ref (cadr form) 'binding))
                      env)))))))

(define (process-syntax form env name env-or-whatever)
  (let ((eval+env (force (reflective-tower env))))
    (make-transform ((car eval+env) form (cdr eval+env))
            env-or-whatever syntax-type form name)))

(define (get-funny env name)
  (let ((binding (lookup env name)))
    (if (binding? binding)
    (binding-static binding)
    #f)))

; An environment's "reflective tower" is a promise that is expected to
; deliver, when forced, a pair (eval . env).

(define funny-name/reflective-tower
  (string->symbol ".reflective-tower."))

(define (reflective-tower env)
  (or (get-funny env funny-name/reflective-tower)
      (error "environment has no environment for syntax" env)))


; --------------------
; The horror of internal defines

; The continuation argument to SCAN-BODY takes two arguments: a list
; of definition nodes, and a list of other things (nodes and
; expressions).

(define (scan-body forms env cont)
  (if (or (null? forms)
      (null? (cdr forms)))
      (cont '() forms)            ;+++ tiny compiler speedup?
      (scan-body-forms forms env '()
               (lambda (defs exps env)
             (cont defs exps)))))

(define (scan-body-forms forms env defs cont)
  (if (null? forms)
      (cont defs '() env)
      (let ((node (classify (car forms) env))
        (forms (cdr forms)))
    (cond ((define-node? node)
           (scan-body-forms forms
                (let ((name (cadr (node-form node))))
                  (bind1 name
                     ;; Shadow, and don't cache lookup
                     (make-node operator/name name)
                     env))
                (cons node defs)
                cont))
          ((begin-node? node)
           (scan-body-forms (cdr (node-form node))
                env
                defs
                (lambda (new-defs exps env)
                  (cond ((null? exps)
                     (scan-body-forms forms
                              env
                              new-defs
                              cont))
                    ((eq? new-defs defs)
                     (cont defs
                           (append exps forms)
                           env))
                    (else (body-lossage node env))))))
          (else
           (cont defs (cons node forms) env))))))

(define (body-lossage node env)
  (syntax-error "definitions and expressions intermixed"
        (schemify node env)))


(define begin-node? (node-predicate 'begin syntax-type))

; --------------------
; Variable types

(define (variable-type type)
  (list 'variable type))

(define (variable-type? type)
  (and (pair? type) (eq? (car type) 'variable)))
(define variable-value-type cadr)

; Used in two places:
; 1. GET-LOCATION checks to see if the context of use (either variable
;    reference or assignment) is compatible with the declared type.
; 2. CHECK-STRUCTURE checks to see if the reconstructed type is compatible
;    with any type declared in the interface.

(define (compatible-types? have-type want-type)
  (if (variable-type? want-type)
      (and (variable-type? have-type)
       (same-type? (variable-value-type have-type)
               (variable-value-type want-type)))
      (meet? (if (variable-type? have-type)
         (variable-value-type have-type)
         have-type)
         want-type)))


; Usual type for Scheme variables.

(define usual-variable-type (variable-type value-type))


(define undeclared-type ':undeclared)    ;cf. really-export macro


; Associate a reader (parser) with an environment.

(define funny-name/reader (string->symbol ".reader."))

;(define (set-package-reader! p reader)
;  (package-define-funny! p funny-name/reader reader))

(define (environment-reader env)
  (or (get-funny env funny-name/reader) read))